home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr40 / aprs67.zip / DEFRAGB.BAS < prev    next >
BASIC Source File  |  1995-02-20  |  15KB  |  481 lines
  1. REM Program DEFRAG.BAS
  2. REM
  3. REM This program takes the output of the mapfix program and shuffles the
  4. REM line sequence so that adjoining line segments are placed in adjacent
  5. REM positions and can be joined.
  6.  
  7. REM ************** MODIFICATION HISTORY ****************
  8. REM  30AUG94  W7KKE  Distributed "pre-beta test" version with known
  9. REM                  bugs due to interest expressed in 1:100,000 USGS
  10. REM                  CD ROM maps.
  11. REM  27OCT94  W7KKE  Added counter to track number of passes with no changes
  12. REM                  so program would exit out of endless loop.
  13. REM  20FEB95  WB4APR added error trap for pre-existence of SCRATCH files
  14. REM                  and changed RENAME to COPY at end of file
  15.  
  16. mxln = 40 'Maximum number of line segments
  17. mxpnt = 500 'Maximum number of x/y points (in any SINGLE line)
  18.  
  19. REM $DYNAMIC
  20. DIM header$(10)
  21. DIM line$(mxln)
  22. DIM x(mxln, mxpnt) AS INTEGER
  23. DIM y(mxln, mxpnt) AS INTEGER
  24. DIM rx(mxpnt) AS INTEGER
  25. DIM ry(mxpnt) AS INTEGER
  26. DIM tempx(mxpnt) AS INTEGER
  27. DIM tempy(mxpnt) AS INTEGER
  28. DIM tempx2(mxpnt) AS INTEGER
  29. DIM tempy2(mxpnt) AS INTEGER
  30. DIM high(mxln) AS INTEGER
  31. DIM x AS INTEGER
  32. DIM y AS INTEGER
  33. DIM i AS INTEGER
  34. DIM k AS INTEGER
  35.  
  36. top:
  37. 'Zero the flags
  38. changes = 0
  39. pass = 0
  40. eflag = 0
  41. joined = 0 ' for debugging only
  42.  
  43. ON ERROR GOTO ErrorKill
  44. KILL "scratch1.tmp"
  45. KILL "scratch2.tmp"
  46. ON ERROR GOTO 0
  47.  
  48.  
  49. CLS
  50. prompt:
  51.    pass = 0
  52.   REM  ON ERROR GOTO Errorfix
  53.   'F$ = "livint.map"
  54.   INPUT "Enter File name of source data"; F$
  55.  
  56. readit:
  57.    k = 0
  58.    IF pass > 0 THEN F$ = "scratch1.tmp"
  59.    OPEN F$ FOR INPUT AS #3
  60.  
  61.    IF pass = 0 THEN
  62.     'Fo$ = "temp.map"
  63.     INPUT "Enter file name for output."; Fo$
  64.      realfile$ = Fo$
  65.      Fo$ = "scratch2.tmp"
  66.    END IF
  67.   
  68.    OPEN Fo$ FOR OUTPUT AS #4
  69.  
  70. Loadit:
  71.         FOR i = 1 TO 9 ' Get first 10 lines of map file which contain
  72.                        ' the setup information.
  73.           LINE INPUT #3, a$
  74.           header$(i) = a$
  75.        
  76.         NEXT i
  77.         
  78.         'replace header line 8 with new comment
  79.         header$(8) = "Map generated from USGS 1:100,000 CD ROM"
  80.  
  81. storehdr: 'Place the map header info in the output file.
  82.         FOR i = 1 TO 9
  83.           PRINT #4, header$(i)
  84.         NEXT i
  85.      
  86.       k = k + 1        'Increment the line counter
  87. collect: 'Collect line segments from the map file
  88.    
  89.      eflag = 0
  90.      i = 0
  91.        
  92.         LINE INPUT #3, a$  'This is the first line label
  93.         line$(k) = a$
  94.  
  95.      DO WHILE NOT EOF(3)
  96.        INPUT #3, x, y   'Get the line segment x/y point
  97.         i = i + 1
  98.  
  99.          IF x = 0 AND y = -1 THEN
  100.               high(k) = i
  101.               x(k, i) = x
  102.               y(k, i) = y
  103.               IF high(k) = 1 THEN STOP
  104.               k = k + 1
  105.               IF i > hiseg THEN hiseg = i
  106.               i = 0
  107.               eflag = 1
  108.           END IF
  109.        
  110.           IF x = 0 AND y = 0 THEN
  111.               high(k) = i
  112.               x(k, i) = x
  113.               y(k, i) = y
  114.               k = k + 1
  115.               IF i > hiseg THEN hiseg = i
  116.               i = 0
  117.             
  118.              LINE INPUT #3, a$  'This is the line label for the next line
  119.              'PRINT "reading "; a$
  120.              line$(k) = a$
  121.               
  122.                IF k > 1 THEN
  123.                   'Store the map color to join proper adjacent lines
  124.                    mapclr1$ = LEFT$(line$(k - 1), 2)  'Store the previous line color
  125.                    mapclr2$ = LEFT$(line$(k), 2)      'Store current line's color
  126.                END IF
  127.           END IF
  128.       
  129.  
  130.         IF x(k - 1, high(k - 1)) <> 0 THEN STOP 'Shouldn't get here
  131.  
  132. dupes:
  133.          'Check for duplicate points in same line segment
  134.            IF i >= 2 AND high(k) > 2 THEN
  135.               IF x(k, i - 1) = x AND y(k, i - 1) = y THEN
  136.                'PRINT
  137.                'PRINT x(k, i - 1), y(k, i - 1)
  138.                'PRINT x, y
  139.                  i = i - 1
  140.                  PRINT "Suppressed duplicate data point in line"; k
  141.                  changes = 1
  142.               END IF
  143.            END IF
  144.  
  145. join:
  146.           'Store last point in previous line
  147.               IF k > 1 AND i = 1 THEN
  148.                 z = k - 1
  149.                 w = high(z) - 1
  150.                 lastx = x(z, w)
  151.                 lasty = y(z, w)
  152.               END IF
  153.  
  154.           'We join the lines if previous line's last x/y matches first x/y
  155.            'of current segment and the line color code matches.
  156.  
  157.   IF k > 1 AND high(z) > 1 AND i = 1 AND x = lastx AND y = lasty AND mapclr1$ = mapclr2$ THEN
  158.  
  159.                'Following is so we can see if segments are joining properly.
  160.                IF lastx = 0 AND lasty = 0 AND x = 0 AND y = 0 THEN STOP
  161.  
  162.                PRINT "joining adjacent map segments"
  163.                k = k - 1 'Backup the line counter
  164.                i = i + high(k)' keep incrementing based on previous high line
  165.                i = i - 1  ' Backup the counter to write over the zero,zero
  166.                changes = 1
  167.                joined = 1 'for debugging
  168.         IF x(k, high(k)) <> 0 THEN STOP
  169.                
  170.   END IF
  171.                 x(k, i) = x
  172.                 y(k, i) = y
  173.  
  174.               'Following for debugging only
  175.               'IF joined = 1 THEN
  176.                  'PRINT x(k, i - 1), y(k, i - 1)
  177.                  'PRINT x(k, i), y(k, i)
  178.                  'joined = 0
  179.               'END IF
  180.  
  181. presson:
  182.            
  183.          IF k < mxln - 1 AND eflag = 0 THEN GOTO lopit ELSE GOTO FILTER
  184.       IF eflag = 1 THEN GOTO FILTER
  185.  
  186. lopit:
  187.       LOOP
  188.       i = 0
  189.        
  190.     IF high(k) = 1 THEN k = k - 1: STOP: GOTO dupes ' get rid of garbage lines
  191.                                                     'shouldn't get here.
  192. FILTER:
  193.       maxk = k - 1
  194.      
  195.  
  196. nearby:
  197.  
  198.      'Check if any other nearby map segments first x,y are same as last x,y
  199.      'in this segment so they can be joined
  200.      'If first x/y of next segment is same as last x/y of previous segement,
  201.      'there is no problem.
  202.  
  203.      PRINT "Testing for nearby ajoining map segments"
  204.    
  205.         FOR kt = 1 TO maxk - 2
  206.            lastx = x(kt, high(kt) - 1)
  207.            lasty = y(kt, high(kt) - 1)
  208.        
  209.          FOR kt1 = (kt + 2) TO maxk - 1
  210.            tstx = x(kt1, 1)
  211.            tsty = y(kt1, 1)
  212.      
  213.           IF lastx = tstx AND lasty = tsty THEN
  214.              PRINT "swapping line"; kt + 1; "with line"; kt1
  215.              IF tstx = 0 AND tsty = 0 THEN STOP
  216.              
  217.         
  218.           'Swap the line segments in the array
  219.           'first, store the next line
  220.             temp1$ = line$(kt + 1)
  221.             thigh = high(kt + 1)
  222.             FOR i = 1 TO high(kt + 1)
  223.               tempx(i) = x(kt + 1, i)
  224.               tempy(i) = y(kt + 1, i)
  225.             NEXT i
  226.            IF tempx(thigh) <> 0 THEN STOP
  227.  
  228.           'next, store the line to be advanced
  229.             temp2$ = line$(kt1)
  230.             thigh2 = high(kt1)
  231.             FOR i = 1 TO high(kt1)
  232.               tempx2(i) = x(kt1, i)
  233.               tempy2(i) = y(kt1, i)
  234.             NEXT i
  235.             IF tempx2(thigh2) <> 0 THEN STOP
  236.  
  237.           'place the advanced line in the second array
  238.             line$(kt + 1) = temp2$
  239.             high(kt + 1) = thigh2
  240.             IF high(kt + 1) = 1 THEN STOP
  241.             FOR i = 1 TO high(kt + 1)
  242.               x(kt + 1, i) = tempx2(i)
  243.               y(kt + 1, i) = tempy2(i)
  244.             NEXT i
  245.               IF x(kt + 1, high(kt + 1)) <> 0 THEN STOP
  246.  
  247.           'place the old second array in the vacated advanced array
  248.             line$(kt1) = temp1$
  249.             high(kt1) = thigh
  250.             IF high(kt1) = 1 THEN STOP
  251.             FOR i = 1 TO high(kt1)
  252.               x(kt1, i) = tempx(i)
  253.               y(kt1, i) = tempy(i)
  254.             NEXT i
  255.             IF x(kt1, high(kt1)) > 0 THEN STOP
  256.           END IF
  257.        NEXT kt1
  258.      NEXT kt
  259.  
  260. IF pass < 3 THEN GOTO fileit
  261.  
  262. TOPTOP:
  263.    
  264.       'Check to see if sequence is reversed when comparing first segment
  265.       'to first segment
  266.       PRINT "Checking for reverse sequence - first to first"
  267.         FOR kt = 1 TO maxk - 2
  268.          firstx = x(kt, 1)
  269.          firsty = y(kt, 1)
  270.     
  271.         FOR kt1 = (kt + 1) TO maxk - 1
  272.            tstx = x(kt1, 1)
  273.            tsty = y(kt1, 1)
  274.    
  275.         IF firstx = tstx AND firsty = tsty THEN
  276.            PRINT "reversing line (top to top)"; kt
  277.              IF tstx = 0 AND tsty = 0 THEN STOP
  278.              
  279.  
  280.           'reverse the line segments in the array
  281.           'the new corrected sequence will be picked up on the next pass
  282.           'first, store the original line
  283.            
  284.             FOR i = 1 TO high(kt)
  285.               tempx(i) = x(kt, i)
  286.               tempy(i) = y(kt, i)
  287.             NEXT i
  288.       
  289.           'now store the points in reverse order
  290.             FOR i = 1 TO high(kt)
  291.               x(kt, i) = tempx(high(kt) - i)
  292.               y(kt, i) = tempy(high(kt) - i)
  293.             NEXT i
  294.          END IF
  295.          NEXT kt1
  296.        NEXT kt
  297.  
  298. IF pass < 6 THEN GOTO fileit
  299.  
  300. lastlast:
  301.  
  302.       'Check to see if sequence is reversed when comparing last segment
  303.       'to last segment
  304.       PRINT "Checking for reverse sequence - last to last"
  305.         FOR kt = 1 TO maxk - 2
  306.          lastx = x(kt, high(kt) - 1)
  307.          lasty = y(kt, high(kt) - 1)
  308.       
  309.         FOR kt1 = (kt + 1) TO maxk - 1
  310.            tstx = x(kt1, high(kt1) - 1)
  311.            tsty = y(kt1, high(kt1) - 1)
  312.  
  313.         IF lastx = tstx AND lasty = tsty THEN
  314.            PRINT "reversing line"; kt1
  315.              
  316.              IF tstx = 0 AND tsty = 0 THEN STOP
  317.  
  318.           'reverse the line segments in the array
  319.           'the new corrected sequence will be picked up on the next pass
  320.           'first, store the original line
  321.             FOR i = 1 TO high(kt1)
  322.               tempx(i) = x(kt1, i)
  323.               tempy(i) = y(kt1, i)
  324.             NEXT i
  325.         
  326.           'now store the points in reverse order
  327.             FOR i = 1 TO high(kt1)
  328.               x(kt1, i) = tempx(high(kt1) - i)
  329.               y(kt1, i) = tempy(high(kt1) - i)
  330.             NEXT i
  331.            IF x(kt1, high(kt1)) <> 0 THEN STOP
  332.          END IF
  333.         NEXT kt1
  334.        NEXT kt
  335.  
  336. IF pass < 9 THEN GOTO fileit
  337.  
  338. toplast:
  339.           'Compare top figure of first pair with last of other pairs.
  340.           'Reverse the top pair if match found.
  341.      
  342.       PRINT "Checking for reverse sequence - top to last"
  343.         FOR kt = 1 TO maxk - 2
  344.          firstx = x(kt, 1)
  345.          firsty = y(kt, 1)
  346.       
  347.         FOR kt1 = (kt + 1) TO maxk - 1
  348.            tstx = x(kt1, high(kt1) - 1)
  349.            tsty = y(kt1, high(kt1) - 1)
  350.  
  351.         IF firstx = tstx AND firsty = tsty THEN
  352.            PRINT "reversing line"; kt
  353.              IF tstx = 0 AND tsty = 0 THEN STOP
  354.  
  355.           'reverse the line segments in the first array.
  356.           'the new corrected sequence will be picked up on the next pass.
  357.           'first, store the original line.
  358.             FOR i = 1 TO high(kt)
  359.               tempx(i) = x(kt, i)
  360.               tempy(i) = y(kt, i)
  361.             NEXT i
  362.         
  363.           'now store the points in reverse order
  364.             FOR i = 1 TO high(kt)
  365.               x(kt, i) = tempx(high(kt) - i)
  366.               y(kt, i) = tempy(high(kt) - i)
  367.             NEXT i
  368.            IF x(kt, high(kt)) <> 0 THEN STOP
  369.           END IF
  370.           NEXT kt1
  371.        NEXT kt
  372.  
  373. fileit:
  374.       maxnum = maxnum + k
  375.       IF EOF(3) THEN
  376.         PRINT
  377.         PRINT "Number of line segments = "; maxnum
  378.         PRINT "Highest number of points per line = "; hiseg
  379.         hiseg = 0' zero so counter will be valid after next pass
  380.       END IF
  381.  
  382.     'Print the revised array to the file
  383.     PRINT
  384.     PRINT "Printing revised array to disk"
  385.      FOR i = 1 TO maxk
  386.          
  387.         'Corrects problem with missing line due to the sequence of reading
  388.         'data.
  389.         IF i = 1 AND LEN(line$(1)) < 9 THEN
  390.            ' for debugging, show the original line
  391.            ' PRINT "bad "; line$(1)
  392.            ' FOR x = 1 TO high(1)
  393.            ' PRINT "original "; x(1, x), y(1, x)
  394.            ' NEXT x
  395.  
  396.             'shift data points down one to make room at top for data which
  397.             'was sucked into line$
  398.            
  399.             FOR x = high(1) TO 1 STEP -1
  400.                 x(1, x + 1) = x(1, x)
  401.                 y(1, x + 1) = y(1, x)
  402.             NEXT x
  403.             'bump the counter for this line by one
  404.             high(1) = high(1) + 1
  405.  
  406.             'put an end of segment marker for this segment
  407.             x(1, high(1)) = 0
  408.             y(1, high(1)) = 0
  409.            
  410.             'retrieve the line segment data which was in the header line
  411.             a = INSTR(line$(1), ",")
  412.             b = LEN(line$(1))
  413.             x(1, 1) = VAL(LEFT$(line$(1), a - 1))
  414.             y(1, 1) = VAL(RIGHT$(line$(1), b - a))
  415.             line$(1) = lost$
  416.             lflag = 0'Reset the "lost" flag so it can pick up lost lable again
  417.         
  418.          'Following for debugging this routine
  419.            ' PRINT "Fixing "; line$(1)
  420.            ' FOR x = 1 TO high(1)
  421.            '   PRINT "fixing "; x(1, x), y(1, x)
  422.            ' NEXT x
  423.         END IF
  424.  
  425.         IF k = mxln - 1 AND lflag = 0 THEN lost$ = a$: lflag = 1
  426.         PRINT #4, line$(i)
  427.         FOR ii = 1 TO high(i)
  428.            WRITE #4, x(i, ii), y(i, ii)
  429.         NEXT ii
  430.        IF high(i) > hiseg THEN hiseg = high(i)
  431.      NEXT i
  432.     k = 1 'reset the line segment counter
  433.    IF eflag = 1 THEN GOTO endit
  434.     
  435.     GOTO collect 'go back to the start and run through the filter again.
  436.                  'Only gets here when end of file not yet reached.
  437.  
  438. endit:
  439.        IF changes = 1 THEN  'Keep looping through the filter until there
  440.                             'are no more changes (i.e. changes = 0).
  441.            pass = pass + 1  'Increment the pass counter
  442.            PRINT
  443.            PRINT "Starting pass"; pass + 1
  444.            CLOSE
  445.            maxnum = 0
  446.            'swap the temporary files and kill the old one
  447.            IF pass > 1 THEN KILL "scratch1.tmp"
  448.            NAME "scratch2.tmp" AS "scratch1.tmp"
  449.            changes = 0 'Zero the changes flag
  450.            GOTO readit
  451.        END IF
  452.       
  453.        IF changes = 0 THEN
  454.         CLOSE
  455.          SHELL "copy scratch1.tmp " + realfile$
  456.        END IF
  457.  
  458.  PRINT
  459.  PRINT
  460.  PRINT "WARNING, DEFRAG does NOT transfer map labels!"
  461.  PRINT
  462.  PRINT "Usually not a problem during map building from source CD data, but"
  463.  PRINT "if you are using DEFRAG on an EXISTING mapfile with LABELS, you will"
  464.  PRINT "have to separately use a DOS editor to move the LABELS to the new file!"
  465.  PRINT
  466.  PRINT
  467.  
  468.  INPUT "Filter another map"; a$
  469.  IF UCASE$(a$) = "Y" THEN GOTO top
  470.  SYSTEM
  471.  
  472.  
  473. ErrorKill:
  474.  BEEP
  475.  IF ERR = 53 THEN RESUME NEXT
  476.  ON ERROR GOTO 0
  477.  RESUME
  478.  
  479.  END
  480.  
  481.